;; $Id: annotation.scm,v 1.6 1998/11/04 23:45:03 jmb Exp $
;;-----------------------------------------------------------------------
;; Purpose---
;;    A rubberbander to make it easier to see where annotations have been placed
;;
;; Basic Controls
;;      load this file to turn on the annotion rubberbander
;;     (rbd:clear) to turn it off
;; when it is on
;;     move mouse over topology to pick and highlight and dump info to scheme window
;;     left mouse button to dump more info about currently selected thing
;;     right mouse button to toggle between picking vertices and edges.  Picking faces is always active
;;     shift to pick back faces (actually the second from front instead of first)
;;-----------------------------------------------------------------------
(define annotation-hook-vector
  (vector                                                   ;Hooks
    ; 0 Init-Hook
    #f;(lambda (self))
    ; 1 Start-Hook
    #f;(lambda (self pe))
    ; 2 Update-Hook
    #f;(lambda (self pe))
    ; 3 Stop-Hook
    #f;(lambda (self))
    ; 4 Repaint-Hook
    #f;(lambda (self view))
    ; 5 Position-Hook
    #f;(lambda (self pe))
    ; 6 End-Hook
    #f;(lambda (self))
    ))

(define (rb-annotations)
  (rbd:scheme #t
              annotation-hook-vector
              (make-vector 1)                                                 ;Locals
              )
  )
(define pick-small pick:edge)
(define picked '())

(set! mouse-down-hook
      (lambda (pe)
        (if (event:right? pe)
            (if (eqv? pick-small pick:edge)
                (set! pick-small pick:vertex)
                (set! pick-small pick:edge))
            (if (entity? picked)
                (map entity:debug (entity:annotations picked) (make-list 10 2))))))


(define entity:outputs
  (lambda (entity)
    (let* ((annos (entity:annotations entity))
           (outputs '()))
      (for-each (lambda (anno)
                  (let ((these-outputs (annotation:outputs anno)))
                    (if (not (member entity these-outputs))
                        (if (null? outputs)
                            (set! outputs these-outputs)
                            (append! outputs these-outputs)))))
                annos)
      outputs)))

(define entity:inputs
  (lambda (entity)
    (let* ((annos (entity:annotations entity))
           (inputs '()))
      (for-each (lambda (anno)
                  (let ((these-inputs (annotation:inputs anno)))
                    (if (null? inputs)
                        (set! inputs these-inputs)
                        (append! inputs these-inputs))))
                annos)
      inputs)))

(define entity:set-color-deep
  (lambda (entity color)
    (begin
      (entity:set-color entity color)
      (if (face? entity)
          (map entity:set-color (entity:edges entity) (make-list 1000 color))))))

(define highlight-annotated-entity
  (lambda (entity onoff)
    (let ((inputs (entity:inputs entity))
          (outputs (entity:outputs entity))
          (red (make-list 1000 (color:rgb 255 0 0)))
          (magenta (make-list 1000 (color:rgb 255 0 255)))
          (green (make-list 1000 (color:rgb 0 255 0)))
          (white (color:rgb 255 255 255)))
      (begin
        (roll:mark-start)
        (env:set-auto-display #f)
        (if (eqv? onoff #t)
            (begin
              (format #t "Turning highlights on for ~a ~%" entity)
              (map entity:set-color-deep outputs red) ; outputs red
              (map entity:set-color-deep inputs magenta) ; inputs magenta
              ;(entity:set-color-deep entity white) ; the entity white
              (entity:set-highlight entity #t))
            (begin
              (format #t "Turning highlights OFF for ~a ~%" entity)
              (map entity:set-color-deep outputs green) ; outputs back to green
              (map entity:set-color-deep inputs green) ; inputs back to green
              ;(entity:set-color-deep entity (color:rgb 0 255 0)) ; the entity back to green
              (entity:set-highlight entity #f)))
        (env:set-auto-display #t)
        (map view:refresh (env:views))
        (roll:mark-end)))))

(define display-annotated-entity
  (lambda (entity)
    (let ((annos (entity:annotations entity)))
      (if (null? annos)
          (format #t "~a Not Annotated ~%" (entity:debug entity))
          (begin
            (format #t "~a ~%" (entity:debug entity))
            (map (lambda (anno)
                   (format #t "    Annotated as ~a of ~a ~%"
                           (annotation:member-name anno entity)
                           (entity:debug anno)))
                 annos))))))

(vector-set! annotation-hook-vector 2
             (lambda (self pe)                              ;update-hook
               (let* (
                       (face (pick:face pe (if (event:shift? pe) 2 1)))
                       (small (pick-small pe))
                       ;(vertex (pick:vertex pe))
                       ; ent is most specific of successful pick.  I had wanted to pick face,edge,vertex
                       ; and then take the smallest, but pick:vertex always succeeds if pick:edge succeeds
                       ; (It finds the closest vertex on the edge) so we use the right-mouse-down event
                       ; to toggle between edges and vertices in pick-small.
                       (ent ;(if (vertex? vertex) vertex
                         (if (entity? small) small
                             (if (face? face) face
                                 '())));)
                       (last-ent (rbd:scheme-get-local self 0))
                       )
                 (if (entity? ent)
                     (begin
                       ;(display (entity:debug ent))
                       (set! picked ent)
                       (if (and (entity? last-ent)(not (eqv? ent last-ent)))
                           (begin
                             ;(display "clearing highlight from last-ent")
                             (highlight-annotated-entity last-ent #f)))
                       (if (not (eqv? ent last-ent))
                           (begin
                             (rbd:scheme-set-local self 0 ent)
                             (highlight-annotated-entity ent #t)
                             (display-annotated-entity ent))))))))
(rb-annotations)
